home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / segment.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  231 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; The byte code compiler's assembly phase.
  5.  
  6. (define make-segment cons)
  7. (define segment-size car);number of bytes that will be taken in the code vector
  8. (define segment-emitter cdr)
  9.  
  10. (define (segment->template segment name pc-in-parent)
  11.   (let* ((cv (make-code-vector (segment-size segment) 0))
  12.      (astate (make-astate cv))
  13.      (parent-data (fluid $debug-data))
  14.      (name (if (if (name? name)
  15.                (keep-procedure-names?)
  16.                (keep-file-names?))  ;string, or pair, or something
  17.            name #f))
  18.      (debug-data (new-debug-data (if (name? name) (name->symbol name) name)
  19.                      parent-data ;(debug-data-if-interesting ?)
  20.                      pc-in-parent)))
  21.     (let-fluid $debug-data debug-data
  22.       (lambda ()
  23.     (let ((maps (emit-with-environment-maps! astate segment)))
  24.       (set-debug-data-env-maps! debug-data maps)
  25.       (make-immutable! cv)
  26.       (segment-data->template cv
  27.                   (debug-data->info debug-data)
  28.                   (reverse (astate-literals astate))))))))
  29.  
  30. (define (segment-data->template cv debug-data literals)
  31.   (let ((template (make-template (+ template-overhead (length literals)) 0)))
  32.     (set-template-code! template cv)
  33.     (set-template-info! template debug-data)
  34.     (do ((lits literals (cdr lits))
  35.      (i template-overhead (+ i 1)))
  36.     ((null? lits) template)
  37.       (template-set! template i (car lits)))))
  38.  
  39.  
  40. ; "astate" is short for "assembly state"
  41.  
  42. (define-record-type assembly-state :assembly-state
  43.   (make-assembly-state cv pc count lits)
  44.   (cv    astate-code-vector)
  45.   (pc    astate-pc    set-astate-pc!)
  46.   (count astate-count set-astate-count!)
  47.   (lits  astate-literals  set-astate-literals!))
  48.  
  49. (define (make-astate cv)
  50.   (make-assembly-state cv 0 template-overhead '()))
  51.  
  52. (define (emit-byte! a byte)
  53.   (code-vector-set! (astate-code-vector a) (astate-pc a) byte)
  54.   (set-astate-pc! a (+ (astate-pc a) 1)))
  55.  
  56. (define (emit-literal! a thing)
  57.   (emit-byte! a
  58.           (let ((probe (position thing (astate-literals a)))
  59.             (count (astate-count a)))
  60.         (if probe
  61.             ;; +++  Eliminate duplicate entries.
  62.             ;; Not necessary, just a modest space saver [how much?].
  63.             ;; Measurably slows down compilation.
  64.             ;; when 1 thing, lits = (x), count = 3, probe = 0, want 2
  65.             (- (- count probe) 1)
  66.             (begin
  67.               (if (>= count byte-limit)
  68.               (error "compiler bug: too many literals"
  69.                  thing))
  70.               (set-astate-literals! a (cons thing (astate-literals a)))
  71.               (set-astate-count! a (+ count 1))
  72.               count)))))
  73.  
  74.  
  75. (define (emit-segment! astate segment)
  76.   ((segment-emitter segment) astate))
  77.  
  78.  
  79. ; Segment constructors
  80.  
  81. (define empty-segment
  82.   (make-segment 0 (lambda (astate) #f)))
  83.  
  84. (define (instruction opcode . operands)
  85.   (make-segment (+ 1 (length operands))
  86.         (lambda (astate)
  87.           (emit-byte! astate opcode)
  88.           (for-each (lambda (operand)
  89.                   (emit-byte! astate operand))
  90.                 operands))))
  91.  
  92. (define (sequentially . segments)
  93.   (reduce sequentially-2 empty-segment segments))
  94.  
  95. (define (sequentially-2 seg1 seg2)
  96.   (cond ((eq? seg1 empty-segment) seg2) ;+++ speed up the compiler a tad
  97.     ((eq? seg2 empty-segment) seg1) ;+++
  98.     (else
  99.      (make-segment (+ (segment-size seg1)
  100.               (segment-size seg2))
  101.                (lambda (astate)
  102.              (emit-segment! astate seg1)
  103.              (emit-segment! astate seg2)))))) ;tail call
  104.  
  105. ; Literals are obtained from the template.
  106.  
  107. (define (instruction-with-literal opcode thing)
  108.   (make-segment 2
  109.         (lambda (astate)
  110.           (emit-byte! astate opcode)
  111.           (emit-literal! astate thing))))
  112.  
  113. ; So are locations.
  114.  
  115. (define (instruction-with-location opcode thunk)
  116.   (make-segment 2
  117.         (lambda (astate)
  118.           (emit-byte! astate opcode)
  119.           ;; But: there really ought to be multiple entries
  120.           ;; depending on how the name is qualified.  
  121.           (emit-literal! astate (thunk)))))
  122.  
  123.  
  124. ; Templates for inferior closures are also obtained from the
  125. ; (parent's) template.
  126.  
  127. (define (instruction-with-template opcode segment name)
  128.   (make-segment 2
  129.         (lambda (astate)
  130.           (emit-byte! astate opcode)
  131.           (emit-literal! astate
  132.                  (segment->template segment
  133.                             name
  134.                             (astate-pc astate))))))
  135.  
  136. ; Labels.  Each label maintains a list of pairs (instr . origin).
  137. ; Instr is the index of the first of two bytes that will hold the jump
  138. ; target offset, and the offset stored will be (- jump-target origin).
  139.  
  140. (define (make-label) (list #f))
  141.  
  142. (define (instruction-using-label opcode label . rest)
  143.   (let ((segment (apply instruction opcode 0 0 rest)))
  144.     (make-segment (segment-size segment)
  145.           (lambda (astate)
  146.             (let ((instr (+ (astate-pc astate) 1)))
  147.               (emit-segment! astate segment)
  148.               (if (car label)
  149.               (warn "backward jumps not supported")
  150.               (set-cdr! label
  151.                     (cons (cons instr (astate-pc astate))
  152.                       (cdr label)))))))))
  153.  
  154. (define (attach-label label segment)
  155.   (make-segment
  156.      (segment-size segment)
  157.      (lambda (astate)
  158.        (let ((pc (astate-pc astate))
  159.          (cv (astate-code-vector astate)))
  160.      (for-each (lambda (instr+origin)
  161.              (let ((instr (car instr+origin))
  162.                (origin (cdr instr+origin)))
  163.                (let ((offset (- pc origin)))
  164.              (code-vector-set! cv instr
  165.                        (quotient offset byte-limit))
  166.              (code-vector-set! cv (+ instr 1)
  167.                        (remainder offset byte-limit)))))
  168.            (cdr label))
  169.      (set-car! label pc)
  170.      (emit-segment! astate segment)))))
  171.  
  172. ; byte-limit is larger than the largest value that will fit in one opcode
  173. ; byte.
  174.  
  175. (define byte-limit (expt 2 bits-used-per-byte))
  176.  
  177.  
  178. ; Special segments for maintaining debugging information.  Not
  179. ; essential for proper functioning of compiler.
  180.  
  181. (define $debug-data (make-fluid #f))
  182.  
  183. ; Keep track of source code at continuations.
  184.  
  185. (define (note-source-code info segment)
  186.   (if (keep-source-code?)
  187.       (make-segment (segment-size segment)
  188.             (lambda (astate)
  189.               (emit-segment! astate segment)
  190.               (let ((dd (fluid $debug-data)))
  191.             (set-debug-data-source!
  192.              dd
  193.              (cons (cons (astate-pc astate)
  194.                      ;; Abbreviate this somehow?
  195.                      (if (pair? info)
  196.                      (cons (car info)
  197.                            (schemify (cdr info)))
  198.                      ;; Name might be generated...
  199.                      info))
  200.                    (debug-data-source dd))))))
  201.       segment))
  202.  
  203. ; Keep track of variable names from lexical environments.
  204. ; Each environment map has the form
  205. ;    #(pc-before pc-after (var ...) (env-map ...))
  206.  
  207. (define (note-environment vars segment)
  208.   (if (keep-environment-maps?)
  209.       (make-segment (segment-size segment)
  210.             (lambda (astate)
  211.               (let* ((pc-before (astate-pc astate))
  212.                  (env-maps
  213.                   (emit-with-environment-maps! astate segment)))
  214.             (set-fluid! $environment-maps
  215.                     (cons (vector pc-before
  216.                           (astate-pc astate)
  217.                           (list->vector
  218.                            (map name->symbol vars))
  219.                           env-maps)
  220.                       (fluid $environment-maps))))))
  221.       segment))
  222.  
  223. (define (emit-with-environment-maps! astate segment)
  224.   (let-fluid $environment-maps '()
  225.     (lambda ()
  226.       (emit-segment! astate segment)
  227.       (fluid $environment-maps))))
  228.  
  229. (define $environment-maps (make-fluid '()))
  230. (define environment-maps-table (make-table))
  231.